home *** CD-ROM | disk | FTP | other *** search
/ Amiga Plus 2000 #5 / Amiga Plus CD - 2000 - No. 5.iso / Tools / Dev / fpc / inc / heap.inc < prev    next >
Encoding:
Text File  |  1998-10-28  |  31.8 KB  |  1,106 lines
  1. {
  2.     $Id: heap.inc,v 1.5 1998/08/17 12:27:17 carl Exp $
  3.     This file is part of the Free Pascal run time library.
  4.     Copyright (c) 1993,97 by the Free Pascal development team.
  5.  
  6.     See the file COPYING.FPC, included in this distribution,
  7.     for details about the copyright.
  8.  
  9.     This program is distributed in the hope that it will be useful,
  10.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  11.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  12.  
  13.  **********************************************************************}
  14.  
  15. {****************************************************************************
  16.                functions for heap management in the data segment
  17.  ****************************************************************************}
  18. {**** 10/06/97 added checkings and corrected some bugs in getmem/freemem ****}
  19. {**** Pierre Muller *********************************************************}
  20.  
  21. { three conditionnals here }
  22.  
  23. { TEMPHEAP to  allow to split the heap in two parts for easier release}
  24. { started for the compiler }
  25. { USEBLOCKS if you want special allocation for small blocks }
  26. { CHECKHEAP if you want to test the heap integrity }
  27.  
  28. {$IfDef CHECKHEAP}
  29.     { 4 levels of tracing }
  30.     const tracesize = 4;
  31.     type   pheap_mem_info = ^heap_mem_info;
  32.            heap_mem_info = record
  33.            next,previous : pheap_mem_info;
  34.            size : longint;
  35.            sig : longint; {dummy number for test }
  36.            calls : array [1..tracesize] of longint;
  37.            end;
  38.            { size 8*4 = 32 }
  39.     { help variables for debugging with GDB }
  40.     const check : boolean = false;
  41.     const last_assigned : pheap_mem_info = nil;
  42.     const growheapstop : boolean = false;
  43.  
  44.     const free_nothing : boolean = false;
  45.     const trace : boolean = true;
  46.     const getmem_nb : longint = 0;
  47.     const freemem_nb : longint = 0;
  48. {$EndIf CHECKHEAP}
  49.  
  50.     const
  51.        heap_split : boolean = false;
  52.        max_size = 256;
  53.        maxblock = max_size div 8;
  54.        freerecord_list_length : longint = 0;
  55.  
  56.     var
  57.        _memavail : longint;
  58.        _internal_heapsize : longint;
  59.  
  60.     type
  61. {$ifdef UseBlocks}
  62.        tblocks   = array[1..maxblock] of pointer;
  63.        pblocks   = ^tblocks;
  64.        tnblocks  = array[1..maxblock] of longint;
  65.        pnblocks  = ^tnblocks;
  66. {$endif UseBlocks}
  67.        pheapinfo = ^theapinfo;
  68.        theapinfo = record
  69.          heaporg,heapptr,heapend,freelist : pointer;
  70.          memavail,heapsize : longint;
  71. {$ifdef UseBlocks}
  72.          block : pblocks;
  73.          nblock : pnblocks;
  74. {$endif UseBlocks}
  75. {$IfDef CHECKHEAP}
  76.         last_mem : pheap_mem_info;
  77.         nb_get,nb_free : longint;
  78. {$EndIf CHECKHEAP}
  79.          end;
  80.     type
  81.        pfreerecord = ^tfreerecord;
  82.  
  83.        tfreerecord = record
  84.           next : pfreerecord;
  85.           size : longint;
  86.        end;
  87.  
  88.     var
  89.        baseheap : theapinfo;
  90.        curheap : pheapinfo;
  91. {$ifdef TEMPHEAP}
  92.        tempheap : theapinfo;
  93.        otherheap : pheapinfo;
  94. {$endif TEMPHEAP}
  95.  
  96. {$ifdef UseBlocks}
  97.        baseblocks : tblocks;
  98.        basenblocks : tnblocks;
  99. {$endif UseBlocks}
  100.  
  101. { this is not supported by FPK <v093
  102.     const
  103.        blocks : pblocks = @baseblocks;
  104.        nblocks : pnblocks = @basenblocks; }
  105.       type
  106.          ppointer = ^pointer;
  107.  
  108. {$ifdef UseBlocks}
  109.     var blocks : pblocks;
  110.         nblocks : pnblocks;
  111. {$endif UseBlocks}
  112.  
  113.  
  114.  
  115.     { Get start address of HEAP, this works well }
  116.     { with AMIGA, ATARI, but for the MAC, the    }
  117.     { HEAP is a pointer!!!                       }
  118. {$IFNDEF MACOS}
  119.     function getheapstart : pointer; assembler;
  120.     asm
  121.        lea.l HEAP,a0
  122.        move.l a0,d0
  123.     end;
  124. {$ELSE}
  125.     function getheapstart : pointer; assembler;
  126.     asm
  127.        move.l HEAP,d0
  128.     end;
  129.  
  130. {$ENDIF MACOS}
  131.  
  132.     function getheapsize : longint; assembler;
  133.     asm
  134.        move.l HEAP_SIZE,d0
  135.     end ['d0'];
  136.  
  137.  
  138.     function heapsize : longint;
  139.  
  140.       begin
  141.          heapsize:=_internal_heapsize;
  142.       end;
  143.  
  144. {$IfDef CHECKHEAP}
  145.     procedure call_stack(p : pointer);
  146.       var i : longint;
  147.           pp : pheap_mem_info;
  148.       begin
  149.  
  150.         if trace then
  151.           begin
  152.              pp:=pheap_mem_info(p-sizeof(heap_mem_info));
  153.              writeln('Call trace of 0x',hexstr(longint(p),8));
  154.              writeln('of size ',pp^.size);
  155.              for i:=1 to tracesize do
  156.                begin
  157.                  writeln(i,' 0x',hexstr(pp^.calls[i],8));
  158.                end;
  159.           end
  160.         else
  161.           writeln('tracing not enabled, sorry !!');
  162.       end;
  163.  
  164.     procedure dump_heap(mark : boolean);
  165.       var pp : pheap_mem_info;
  166.       begin
  167.          pp:=last_assigned;
  168.          while pp<>nil do
  169.            begin
  170.               call_stack(pp+sizeof(heap_mem_info));
  171.               if mark then
  172.                 pp^.sig:=$AAAAAAAA;
  173.               pp:=pp^.previous;
  174.            end;
  175.       end;
  176.  
  177.     procedure dump_free(p : pheap_mem_info);
  178.       var bp : longint;
  179.       begin
  180.          Writeln('Marked memory at ',HexStr(longint(p),8),' released');
  181.          call_stack(p+sizeof(heap_mem_info));
  182.          asm
  183.             move.l (a6),a0
  184.             move.l (a0),d0
  185.             move.l d0,bp
  186.          end;
  187.          dump_stack(bp);
  188.       end;
  189.  
  190.     function is_in_getmem_list (p : pointer) : boolean;
  191.         var pp : pheap_mem_info;
  192.             i : longint;
  193.       begin
  194.         is_in_getmem_list:=false;
  195.         pp:=last_assigned;
  196.         i:=0;
  197.         while pp<>nil do
  198.           begin
  199.              if (pp^.sig<>$DEADBEEF) and (pp^.sig <> $AAAAAAAA) then
  200.                begin
  201.                   writeln('error in linked list of heap_mem_info');
  202.                   runerror(204);
  203.                end;
  204.  
  205.              if pp=p then
  206.                begin
  207.                   is_in_getmem_list:=true;
  208.                end;
  209.              pp:=pp^.previous;
  210.              inc(i);
  211.              if i > getmem_nb - freemem_nb then
  212.                writeln('error in linked list of heap_mem_info');
  213.           end;
  214.       end;
  215.  
  216.     function is_in_free(p : pointer) : boolean;
  217.  
  218.       var
  219.          hp : pfreerecord;
  220.  
  221.       begin
  222.          if p>heapptr then
  223.            begin
  224.               is_in_free:=true;
  225.               exit;
  226.            end
  227.          else
  228.            begin
  229.               hp:=freelist;
  230.               while assigned(hp) do
  231.                 begin
  232.                    if (p>=hp) and (p<hp+hp^.size) then
  233.                      begin
  234.                         is_in_free:=true;
  235.                         exit;
  236.                      end;
  237.                    hp:=hp^.next;
  238.                 end;
  239.               is_in_free:=false;
  240.            end;
  241.       end;
  242. {$EndIf CHECKHEAP}
  243.  
  244.     function cal_memavail : longint;
  245.  
  246.       var
  247.          hp : pfreerecord;
  248.          i,ma : longint;
  249.  
  250.       begin
  251.          ma:=heapend-heapptr;
  252. {$ifdef UseBlocks}
  253.          for i:=1 to maxblock do
  254.            ma:=ma+i*8*nblocks^[i];
  255. {$endif UseBlocks}
  256.          hp:=freelist;
  257.          while assigned(hp) do
  258.            begin
  259.               ma:=ma+hp^.size;
  260. {$IfDef CHECKHEAP}
  261.               if (longint(hp^.next)=0) then
  262.                 begin
  263.                    if ((longint(hp)+hp^.size)>longint(heapptr)) then
  264.                      writeln('freerecordlist bad at end ')
  265.                 end
  266.               else
  267.                   if ((longint(hp^.next)<=(longint(hp)+hp^.size)) or
  268.                      ((hp^.size mod 8) <> 0)) then
  269.                   writeln('error in freerecord list ');
  270. {$EndIf CHECKHEAP}
  271.               hp:=hp^.next;
  272.            end;
  273.          cal_memavail:=ma;
  274.       end;
  275.  
  276. {$ifdef TEMPHEAP}
  277.     procedure split_heap;
  278.       var i :longint;
  279.     begin
  280.     if not heap_split then
  281.       begin
  282.       baseheap.heaporg:=heaporg;
  283.       baseheap.heapptr:=heapptr;
  284.       baseheap.freelist:=freelist;
  285.       baseheap.block:=blocks;
  286.       baseheap.nblock:=nblocks;
  287.       longint(baseheap.heapend):=((longint(heapend)+longint(heapptr)) div 16)*8;
  288.       tempheap.heaporg:=baseheap.heapend;
  289.       tempheap.freelist:=nil;
  290.       tempheap.heapptr:=tempheap.heaporg;
  291. {$IfDef CHECKHEAP}
  292.       tempheap.last_mem:=nil;
  293.       tempheap.nb_get:=0;
  294.       tempheap.nb_free:=0;
  295. {$EndIf CHECKHEAP}
  296.       tempheap.heapend:=heapend;
  297.       tempheap.memavail:=longint(tempheap.heapend) - longint(tempheap.heaporg);
  298.       tempheap.heapsize:=tempheap.memavail;
  299.       getmem(tempheap.block,sizeof(tblocks));
  300.       getmem(tempheap.nblock,sizeof(tnblocks));
  301.       for i:=1 to maxblock do
  302.         begin
  303.         tempheap.block^[i]:=nil;
  304.         tempheap.nblock^[i]:=0;
  305.         end;
  306.       heapend:=baseheap.heapend;
  307.       _memavail:=cal_memavail;
  308.       baseheap.memavail:=_memavail;
  309.       baseheap.heapsize:=longint(baseheap.heapend)-longint(baseheap.heaporg);
  310.       curheap:=@baseheap;
  311.       otherheap:=@tempheap;
  312.       heap_split:=true;
  313.       end;
  314.     end;
  315.  
  316.     procedure switch_to_temp_heap;
  317.     begin
  318.     if curheap = @baseheap then
  319.       begin
  320.       baseheap.heaporg:=heaporg;
  321.       baseheap.heapend:=heapend;
  322.       baseheap.heapptr:=heapptr;
  323.       baseheap.freelist:=freelist;
  324.       baseheap.memavail:=_memavail;
  325.       baseheap.block:=blocks;
  326.       baseheap.nblock:=nblocks;
  327. {$IfDef CHECKHEAP}
  328.       baseheap.last_mem:=last_assigned;
  329.       last_assigned:=tempheap.last_mem;
  330.       baseheap.nb_get:=getmem_nb;
  331.       baseheap.nb_free:=freemem_nb;
  332.       getmem_nb:=tempheap.nb_get;
  333.       freemem_nb:=tempheap.nb_free;
  334. {$EndIf CHECKHEAP}
  335.       heaporg:=tempheap.heaporg;
  336.       heapptr:=tempheap.heapptr;
  337.       freelist:=tempheap.freelist;
  338.       heapend:=tempheap.heapend;
  339.       blocks:=tempheap.block;
  340.       nblocks:=tempheap.nblock;
  341.       _memavail:=cal_memavail;
  342.       curheap:=@tempheap;
  343.       otherheap:=@baseheap;
  344.       end;
  345.     end;
  346.  
  347.     procedure switch_to_base_heap;
  348.     begin
  349.     if curheap = @tempheap then
  350.       begin
  351.       tempheap.heaporg:=heaporg;
  352.       tempheap.heapend:=heapend;
  353.       tempheap.heapptr:=heapptr;
  354.       tempheap.freelist:=freelist;
  355.       tempheap.memavail:=_memavail;
  356. {$IfDef CHECKHEAP}
  357.       tempheap.last_mem:=last_assigned;
  358.       last_assigned:=baseheap.last_mem;
  359.       tempheap.nb_get:=getmem_nb;
  360.       tempheap.nb_free:=freemem_nb;
  361.       getmem_nb:=baseheap.nb_get;
  362.       freemem_nb:=baseheap.nb_free;
  363. {$EndIf CHECKHEAP}
  364.       heaporg:=baseheap.heaporg;
  365.       heapptr:=baseheap.heapptr;
  366.       freelist:=baseheap.freelist;
  367.       heapend:=baseheap.heapend;
  368.       blocks:=baseheap.block;
  369.       nblocks:=baseheap.nblock;
  370.       _memavail:=cal_memavail;
  371.       curheap:=@baseheap;
  372.       otherheap:=@tempheap;
  373.       end;
  374.     end;
  375.  
  376.     procedure switch_heap;
  377.     begin
  378.     if not heap_split then split_heap;
  379.     if curheap = @tempheap then
  380.       switch_to_base_heap
  381.       else
  382.       switch_to_temp_heap;
  383.     end;
  384.  
  385.     procedure gettempmem(var p : pointer;size : longint);
  386.  
  387.     begin
  388.        split_heap;
  389.        switch_to_temp_heap;
  390.        allow_special:=true;
  391.        getmem(p,size);
  392.        allow_special:=false;
  393.     end;
  394. {$endif TEMPHEAP}
  395.  
  396.     function memavail : longint;
  397.  
  398.       begin
  399.          memavail:=_memavail;
  400.       end;
  401.  
  402. {$ifdef TEMPHEAP}
  403.     procedure unsplit_heap;
  404.     var hp,hp2,thp : pfreerecord;
  405.     begin
  406.     {heapend can be modified by HeapError }
  407.     if not heap_split then exit;
  408.     if baseheap.heapend = tempheap.heaporg then
  409.       begin
  410.       switch_to_base_heap;
  411.       hp:=pfreerecord(freelist);
  412.       if assigned(hp) then
  413.         while assigned(hp^.next) do hp:=hp^.next;
  414.       if tempheap.heapptr<>tempheap.heaporg then
  415.         begin
  416.            if hp<>nil then
  417.              hp^.next:=heapptr;
  418.            hp:=pfreerecord(heapptr);
  419.            hp^.size:=heapend-heapptr;
  420.            hp^.next:=tempheap.freelist;
  421.            heapptr:=tempheap.heapptr;
  422.         end;
  423.       heapend:=tempheap.heapend;
  424.       _memavail:=cal_memavail;
  425.       heap_split:=false;
  426.       end else
  427.       begin
  428.       hp:=pfreerecord(baseheap.freelist);
  429.       hp2:=pfreerecord(tempheap.freelist);
  430.       while assigned(hp) and assigned(hp2) do
  431.         begin
  432.         if hp=hp2 then break;
  433.         if hp>hp2 then
  434.           begin
  435.           thp:=hp2;
  436.           hp2:=hp;
  437.           hp:=thp;
  438.           end;
  439.         while assigned(hp^.next) and (hp^.next<hp2) do
  440.             hp:=hp^.next;
  441.         if assigned(hp^.next) then
  442.             begin
  443.             thp:=hp^.next;
  444.             hp^.next:=hp2;
  445.             hp:=thp;
  446.             end else
  447.             begin
  448.             hp^.next:=hp2;
  449.             hp:=nil;
  450.             end;
  451.           end ;
  452.       if heapend < tempheap.heapend then
  453.         heapend:=tempheap.heapend;
  454.       if heapptr < tempheap.heapptr then
  455.         heapptr:=tempheap.heapptr;
  456.       freemem(tempheap.block,sizeof(tblocks));
  457.       freemem(tempheap.nblock,sizeof(tnblocks));
  458.       _memavail:=cal_memavail;
  459.       heap_split:=false;
  460.       end;
  461.     end;
  462.  
  463.     procedure releasetempheap;
  464.     begin
  465.     switch_to_temp_heap;
  466. {$ifdef CHECKHEAP}
  467.     if heapptr<>heaporg then
  468.       writeln('Warning in releasetempheap : ',longint(tempheap.heapsize)-longint(tempheap.memavail),' bytes used !');
  469.     dump_heap(true);
  470. {    release(heaporg);
  471.     fillchar(heaporg^,longint(heapend)-longint(heaporg),#0);}
  472. {$endif CHECKHEAP }
  473.     unsplit_heap;
  474.     split_heap;
  475.     end;
  476. {$endif TEMPHEAP}
  477.  
  478.     function maxavail : longint;
  479.  
  480.       var
  481.          hp : pfreerecord;
  482.  
  483.       begin
  484.          maxavail:=heapend-heapptr;
  485.          hp:=freelist;
  486.          while assigned(hp) do
  487.            begin
  488.               if hp^.size>maxavail then
  489.                 maxavail:=hp^.size;
  490.               hp:=hp^.next;
  491.            end;
  492.       end;
  493.  
  494. {$ifdef CHECKHEAP}
  495.      procedure test_memavail;
  496.  
  497.        begin
  498.           if check and (_memavail<>cal_memavail) then
  499.             begin
  500.                writeln('Memavail error in getmem/freemem');
  501.             end;
  502.        end;
  503. {$endif CHECKHEAP}
  504.  
  505.     procedure getmem(var p : pointer;size : longint);[public,alias: 'GETMEM'];
  506.  
  507. {$IfDef CHECKHEAP}
  508.       var i,bp,orsize : longint;
  509.       label check_new;
  510. {$endif CHECKHEAP}
  511.  
  512.       { changed to removed the OS conditionnals }
  513.       function call_heaperror(addr : pointer; size : longint) : integer;
  514.         begin
  515.            asm
  516.               move.l  size,-(sp)
  517.               move.l  addr,a0
  518.               jsr     (a0)
  519.               move.w  d0,@Result
  520.            end;
  521.         end;
  522.  
  523.       var
  524.          last,hp : pfreerecord;
  525.          nochmal : boolean;
  526.          s : longint;
  527.  
  528.       begin
  529. {$ifdef CHECKHEAP}
  530.          if trace then
  531.            begin
  532.               orsize:=size;
  533.               size:=size+sizeof(heap_mem_info);
  534.            end;
  535. {$endif CHECKHEAP}
  536.          if size=0 then
  537.            begin
  538.               p:=heapend;
  539. {$ifdef CHECKHEAP}
  540.               goto check_new;
  541. {$else CHECKHEAP}
  542.               exit;
  543. {$endif CHECKHEAP}
  544.            end;
  545. {$ifdef TEMPHEAP}
  546.          if heap_split and not allow_special then
  547.            begin
  548.            if (@p < otherheap^.heapend) and
  549.               (@p > otherheap^.heaporg) then
  550.               { useful line for the debugger }
  551.              writeln('warning : p and @p are in different heaps !');
  552.            end;
  553. {$endif TEMPHEAP}
  554.          { calc to multiply of 8 }
  555.          if (size mod 8)<>0 then
  556.            size:=size+(8-(size mod 8));
  557.          dec(_memavail,size);
  558. {$ifdef UseBlocks}
  559.          { search cache }
  560.          if size<=max_size then
  561.            begin
  562.               s:=size div 8;
  563.               if assigned(blocks^[s]) then
  564.                 begin
  565.                    p:=blocks^[s];
  566.                    blocks^[s]:=pointer(blocks^[s]^);
  567.                    dec(nblocks^[s]);
  568. {$ifdef CHECKHEAP}
  569.                    goto check_new;
  570. {$else CHECKHEAP}
  571.                    exit;
  572. {$endif CHECKHEAP}
  573.                 end;
  574.            end;
  575. {$endif UseBlocks}
  576.          repeat
  577.            nochmal:=false;
  578.            { search the freelist }
  579.            if assigned(freelist) then
  580.              begin
  581.                 last:=nil;
  582.                 hp:=freelist;
  583.                 while assigned(hp) do
  584.                   begin
  585.                      { take the first fitting block }
  586.                      if hp^.size>=size then
  587.                        begin
  588.                           p:=hp;
  589.                           { need we the whole block ? }
  590.                           if hp^.size>size then
  591.                             begin
  592. {$ifdef UseBlocks}
  593.                                { we must check if we are still below the limit !! }
  594.                                if hp^.size-size<=max_size then
  595.                                  begin
  596.                                     { adjust the list }
  597.                                     if assigned(last) then
  598.                                       last^.next:=hp^.next
  599.                                     else
  600.                                       freelist:=hp^.next;
  601.                                     { insert in chain }
  602.                                     s:=(hp^.size-size) div 8;
  603.                                     ppointer(hp+size)^:=blocks^[s];
  604.                                     blocks^[s]:=hp+size;
  605.                                     inc(nblocks^[s]);
  606.                                  end
  607.                                else
  608. {$endif UseBlocks}
  609.                                begin
  610.                                   (hp+size)^.size:=hp^.size-size;
  611.                                   (hp+size)^.next:=hp^.next;
  612.                                   if assigned(last) then
  613.                                     last^.next:=hp+size
  614.                                   else
  615.                                     freelist:=hp+size;
  616.                                end;
  617.                             end
  618.                           else
  619.                             begin
  620. {$IfDef CHECKHEAP}
  621.                                dec(freerecord_list_length);
  622. {$endif CHECKHEAP}
  623.                                if assigned(last) then
  624.                                  last^.next:=hp^.next
  625.                                else
  626.                                  {this was wrong !!}
  627.                                  {freelist:=nil;}
  628.                                  freelist:=hp^.next;
  629.                             end;
  630. {$ifdef CHECKHEAP}
  631.                             goto check_new;
  632. {$else CHECKHEAP}
  633.                             exit;
  634. {$endif CHECKHEAP}
  635.                        end;
  636.                      last:=hp;
  637.                      hp:=hp^.next;
  638.                   end;
  639.              end;
  640.            { Latly, the top of the heap is checked, to see if there is }
  641.            { still memory available.                                   }
  642.            if heapend-heapptr<size then
  643.              begin
  644.                 if assigned(heaperror) then
  645.                   begin
  646.                      case call_heaperror(heaperror,size) of
  647.                         0 : runerror(203);
  648.                         1 : p:=nil;
  649.                         2 : nochmal:=true;
  650.                      end;
  651.                   end
  652.                 else
  653.                   runerror(203);
  654.              end
  655.            else
  656.              begin
  657.                 p:=heapptr;
  658.                 heapptr:=heapptr+size;
  659.              end;
  660.          until not nochmal;
  661. {$ifdef CHECKHEAP}
  662. check_new:
  663.      inc(getmem_nb);
  664.      test_memavail;
  665.      if trace then
  666.        begin
  667.            asm
  668.               move.l (a6),d0
  669.               move.l d0,bp
  670.            end;
  671.           pheap_mem_info(p)^.sig:=$DEADBEEF;
  672.           pheap_mem_info(p)^.previous:=last_assigned;
  673.           if last_assigned<>nil then
  674.             last_assigned^.next:=pheap_mem_info(p);
  675.           last_assigned:=p;
  676.           pheap_mem_info(p)^.next:=nil;
  677.           pheap_mem_info(p)^.size:=orsize;
  678.           for i:=1 to tracesize do
  679.             begin
  680.                pheap_mem_info(p)^.calls[i]:=get_addr(bp);
  681.                bp:=get_next_frame(bp);
  682.             end;
  683.           p:=p+sizeof(heap_mem_info);
  684.        end;
  685. {$endif CHECKHEAP}
  686.       end;
  687.  
  688.     procedure freemem(var p : pointer;size : longint);[public,alias: 'FREEMEM'];
  689.  
  690.       var
  691.          hp : pfreerecord;
  692. {$ifdef TEMPHEAP}
  693.          heap_switched : boolean;
  694. {$endif TEMPHEAP}
  695.          s : longint;
  696.  
  697.       label freemem_exit;
  698.  
  699.       begin
  700. {$ifdef CHECKHEAP}
  701.          if free_nothing then
  702.            begin
  703.               p:=nil;
  704.               exit;
  705.            end;
  706.      if trace then
  707.        begin
  708.           size:=size+sizeof(heap_mem_info);
  709.           p:=p-sizeof(heap_mem_info);
  710.           { made after heap_switch
  711.           if not (is_in_getmem_list(p)) then
  712.             runerror(204); }
  713.        end;
  714. {$endif CHECKHEAP}
  715.          if size=0 then
  716.            begin
  717.               p:=nil;
  718.               exit;
  719.            end;
  720.          if p=nil then RunError (204);
  721. {$ifdef TEMPHEAP}
  722.          heap_switched:=false;
  723.          if heap_split and not allow_special then
  724.            begin
  725.               if (p <= heapptr) and
  726.                  ( p >= heaporg) and
  727.                  (@p <= otherheap^.heapend) and
  728.                  (@p >= otherheap^.heaporg) then
  729.                 begin
  730.                    writeln('warning : p and @p are in different heaps !');
  731.                 end;
  732.            end;
  733.          if (p<heaporg) or (p>heapptr) then
  734.            begin
  735.               if heap_split and (p<otherheap^.heapend) and
  736.                  (p>otherheap^.heaporg) then
  737.                 begin
  738.                    if (@p >= heaporg) and
  739.                       (@p <= heapptr) and
  740.                       not allow_special then
  741.                       writeln('warning : p and @p are in different heaps !');
  742.                    switch_heap;
  743.                    heap_switched:=true;
  744.                 end
  745.               else
  746.                 begin
  747.                    writeln('pointer ',hexstr(longint(@p),8),' at ',
  748.                      hexstr(longint(p),8),' doesn''t points to the heap');
  749.                    runerror(204);
  750.                 end;
  751.            end;
  752. {$endif TEMPHEAP}
  753. {$ifdef CHECKHEAP}
  754.      if trace then
  755.        begin
  756.           if not (is_in_getmem_list(p)) then
  757.             runerror(204);
  758.           if pheap_mem_info(p)^.sig=$AAAAAAAA then
  759.             dump_free(p);
  760.           if pheap_mem_info(p)^.next<>nil then
  761.             pheap_mem_info(p)^.next^.previous:=pheap_mem_info(p)^.previous;
  762.           if pheap_mem_info(p)^.previous<>nil then
  763.             pheap_mem_info(p)^.previous^.next:=pheap_mem_info(p)^.next;
  764.           if pheap_mem_info(p)=last_assigned then
  765.             last_assigned:=last_assigned^.previous;
  766.        end;
  767. {$endif CHECKHEAP}
  768.          { calc to multiple of 8 }
  769.            size:=(size+7) and not 7;
  770.          _memavail:=_memavail+size;
  771.          if p+size>=heapptr then
  772.            heapptr:=p
  773. {$ifdef UseBlocks}
  774.          { insert into cache }
  775.          else if size<=max_size then
  776.            begin
  777.               s:=size div 8;
  778.               ppointer(p)^:=blocks^[s];
  779.               blocks^[s]:=p;
  780.               inc(nblocks^[s]);
  781.            end
  782. {$endif UseBlocks}
  783.          else
  784.            begin
  785.               { size can be allways set }
  786.               pfreerecord(p)^.size:=size;
  787.  
  788.               { if there is no free list }
  789.               if not assigned(freelist) then
  790.                 begin
  791.                    { then generate one }
  792.                    freelist:=p;
  793.                    pfreerecord(p)^.next:=nil;
  794. {$ifdef CHECKHEAP}
  795.                    inc(freerecord_list_length);
  796. {$endif CHECKHEAP}
  797.                    goto freemem_exit;
  798.                 end;
  799.               if p+size<freelist then
  800.                 begin
  801.                 pfreerecord(p)^.next:=freelist;
  802.                 freelist:=p;
  803. {$ifdef CHECKHEAP}
  804.                 inc(freerecord_list_length);
  805. {$endif CHECKHEAP}
  806.                 goto freemem_exit;
  807.                 end
  808.               else
  809.               if p+size=freelist then
  810.                 begin
  811.                 inc(pfreerecord(p)^.size,pfreerecord(freelist)^.size);
  812.                 pfreerecord(p)^.next:=pfreerecord(freelist)^.next;
  813.                 freelist:=p;
  814.                 { but now it can also connect the next block !!}
  815.                 if p+pfreerecord(p)^.size=pfreerecord(p)^.next then
  816.                   begin
  817.                      inc(pfreerecord(p)^.size,pfreerecord(p)^.next^.size);
  818. {$ifdef CHECKHEAP}
  819.                      dec(freerecord_list_length);
  820. {$endif CHECKHEAP}
  821.                      pfreerecord(p)^.next:=pfreerecord(freelist)^.next^.next;
  822.                   end;
  823.                 goto freemem_exit;
  824.                 end;
  825.               { search the insert position }
  826.               hp:=freelist;
  827.               while assigned(hp) do
  828.                 begin
  829.                    if p<hp+hp^.size then
  830.                       begin
  831.                       writeln('pointer to dispose at ',hexstr(longint(p),8),
  832.                         ' has already been disposed');
  833.                       runerror(204);
  834.                       end;
  835.                    { connecting two blocks ? }
  836.                    if hp+hp^.size=p then
  837.                       begin
  838.                          inc(hp^.size,size);
  839.                          { connecting also to next block ? }
  840.                          if hp+hp^.size=hp^.next then
  841.                            begin
  842.                               inc(hp^.size,hp^.next^.size);
  843. {$ifdef CHECKHEAP}
  844.                               dec(freerecord_list_length);
  845. {$endif CHECKHEAP}
  846.                               hp^.next:=hp^.next^.next;
  847.                            end
  848.                          else
  849.                          if (hp^.next<>nil) and (hp+hp^.size>hp^.next) then
  850.                            begin
  851.                               writeln('pointer to dispose at ',hexstr(longint(p),8),
  852.                                 ' is too big !!');
  853.                               runerror(204);
  854.                             end;
  855.                          break;
  856.                       end
  857.                    { if the end is reached, then concat }
  858.                    else if hp^.next=nil then
  859.                      begin
  860.                         hp^.next:=p;
  861. {$ifdef CHECKHEAP}
  862.                         inc(freerecord_list_length);
  863. {$endif CHECKHEAP}
  864.                         pfreerecord(p)^.next:=nil;
  865.                         break;
  866.                      end
  867.                    { falls der n„chste Zeiger gr”áer ist, dann }
  868.                    { Einh„ngen                                 }
  869.                    else if hp^.next>p then
  870.                      begin
  871.                         { connect to blocks }
  872.                         if p+size=hp^.next then
  873.                           begin
  874.                              pfreerecord(p)^.next:=hp^.next^.next;
  875.                              inc(pfreerecord(p)^.size,hp^.next^.size);
  876.                              { we have to reset the right position }
  877.                              hp^.next:=pfreerecord(p);
  878.                           end
  879.                         else
  880.                           begin
  881.                              pfreerecord(p)^.next:=hp^.next;
  882.                              hp^.next:=p;
  883. {$ifdef CHECKHEAP}
  884.                              inc(freerecord_list_length);
  885. {$endif CHECKHEAP}
  886.                           end;
  887.                         break;
  888.                      end;
  889.                    hp:=hp^.next;
  890.                 end;
  891.            end;
  892.          freemem_exit:
  893. {$ifdef CHECKHEAP}
  894.          inc(freemem_nb);
  895.          test_memavail;
  896. {$endif CHECKHEAP}
  897.          p:=nil;
  898. {$ifdef TEMPHEAP}
  899.          if heap_switched then switch_heap;
  900. {$endif TEMPHEAP}
  901.       end;
  902.  
  903.     procedure release(var p : pointer);
  904.  
  905.       begin
  906.          heapptr:=p;
  907.          freelist:=nil;
  908.          _memavail:=cal_memavail;
  909.       end;
  910.  
  911.     procedure mark(var p : pointer);
  912.  
  913.       begin
  914.          p:=heapptr;
  915.       end;
  916.  
  917.     procedure markheap(var oldfreelist,oldheapptr : pointer);
  918.  
  919.       begin
  920.          oldheapptr:=heapptr;
  921.          oldfreelist:=freelist;
  922.          freelist:=nil;
  923.          _memavail:=cal_memavail;
  924.       end;
  925.  
  926.     procedure releaseheap(oldfreelist,oldheapptr : pointer);
  927.  
  928.       begin
  929.          heapptr:=oldheapptr;
  930.          if longint(freelist) < longint(heapptr) then
  931.            begin
  932.            {here we should reget the freed blocks}
  933.            end;
  934.          freelist:=oldfreelist;
  935.          _memavail:=cal_memavail;
  936.       end;
  937.  
  938. { the sbrk  function is moved to the system.pp }
  939. { as it is system dependent !!                 }
  940. function growheap(size :longint) : integer;
  941.  
  942.   var NewPos,wantedsize : longint;
  943.          hp : pfreerecord;
  944.     Newlimit : longint;
  945.  
  946. begin
  947.    wantedsize:=size;
  948.    size:=size+$ffff;
  949.    size:=size and $ffff0000;
  950.    { Allocate by 64K size }
  951.    { first try 1Meg }
  952.    NewPos:=Sbrk($100000);
  953.    if NewPos=-1 then
  954.      NewPos:=Sbrk(size)
  955.    else
  956.      size:=$100000;
  957.    if (NewPos = -1) then
  958.      begin
  959.         GrowHeap:=0;
  960.         {$IfDef CHECKHEAP}
  961.         writeln('Call to GrowHeap failed');
  962.         readln;
  963.         {$EndIf CHECKHEAP}
  964.         Exit;
  965.      end
  966.    else
  967.      begin
  968.      { make the room clean }
  969. {$ifdef CHECKHEAP}
  970.         Fillword(pointer(NewPos)^,size div 2,$ABCD);
  971.         Newlimit:= (newpos+size) or $3fff;
  972. {$else }
  973.         Fillchar(pointer(NewPos)^,size,#0);
  974. {$endif }
  975.         hp:=pfreerecord(freelist);
  976.         if not assigned(hp) then
  977.           begin
  978.           if pointer(newpos) = heapend then
  979.             heapend:=pointer(newpos+size)
  980.           else
  981.             begin
  982.                if heapend - heapptr > 0 then
  983.                  begin
  984.                     freelist:=heapptr;
  985.                     hp:=pfreerecord(freelist);
  986.                     hp^.size:=heapend-heapptr;
  987.                     hp^.next:=nil;
  988.                  end;
  989.                heapptr:=pointer(newpos);
  990.                heapend:=pointer(newpos+size);
  991.             end;
  992.           end
  993.         else
  994.           begin
  995.              if pointer(newpos) = heapend then
  996.                heapend:=pointer(newpos+size)
  997.              else
  998.                begin
  999.                   while assigned(hp^.next) and (longint(hp^.next) < longint(NewPos)) do
  1000.                     hp:=hp^.next;
  1001.                   if hp^.next = nil then
  1002.                     begin
  1003.                        hp^.next:=pfreerecord(heapptr);
  1004.                        hp:=pfreerecord(heapptr);
  1005.                        hp^.size:=heapend-heapptr;
  1006.                        hp^.next:=nil;
  1007.                        heapptr:=pointer(NewPos);
  1008.                        heapend:=pointer(NewPos+Size);
  1009.                     end
  1010.                   else
  1011.                 begin
  1012.                        pfreerecord(NewPos)^.Size:=Size;
  1013.                        pfreerecord(NewPos)^.Next:=hp^.next;
  1014.                        hp^.next:=pfreerecord(NewPos);
  1015.                     end;
  1016.                end;
  1017.           end;
  1018.         { the wanted size has to be substracted }
  1019.         _memavail:=cal_memavail-wantedsize;
  1020.         { set the total new heap size }
  1021.         asm
  1022.           move.l Size,d0
  1023.           move.l HEAP_SIZE,d1
  1024.           add.l  d0,d1
  1025.           move.l d1,HEAP_SIZE
  1026.         end;
  1027.         GrowHeap:=2;{ try again }
  1028.         _internal_heapsize:=size+_internal_heapsize;
  1029. {$IfDef CHECKHEAP}
  1030.         writeln('Call to GrowHeap succedeed : HeapSize = ',_internal_heapsize,' MemAvail = ',memavail);
  1031.         writeln('New heap part begins at ',Newpos,' with size ',size);
  1032.         if growheapstop then
  1033.           readln;
  1034. {$EndIf CHECKHEAP}
  1035.         exit;
  1036.      end;
  1037. end;
  1038.  
  1039.  
  1040. { This function will initialize the Heap manager and need to be called from
  1041.   the initialization of the system unit }
  1042. procedure InitHeap;
  1043. {$ifdef UseBlocks}
  1044. var
  1045.   i : longint;
  1046. {$endif UseBlocks}  
  1047. begin
  1048. {$ifdef UseBlocks}
  1049.   Blocks:=@baseblocks;
  1050.   Nblocks:=@basenblocks;
  1051.   for i:=1 to maxblock do
  1052.    begin
  1053.      Blocks^[i]:=nil;
  1054.      Nblocks^[i]:=0;
  1055.    end;
  1056. {$endif UseBlocks}
  1057.   Curheap := @baseheap;
  1058. {$ifdef TEMPHEAP}
  1059.   Otherheap := @tempheap;
  1060. {$endif TEMPHEAP}
  1061.   HeapOrg := GetHeapStart;
  1062.   HeapPtr := HeapOrg;
  1063.   _memavail := GetHeapSize;
  1064.   HeapEnd := HeapOrg + _memavail;
  1065.   HeapError := @GrowHeap;
  1066.   _internal_heapsize:=longint(heapend)-longint(heaporg);
  1067.   Freelist := nil;
  1068. end;
  1069.  
  1070. {
  1071.   $Log: heap.inc,v $
  1072.   Revision 1.5  1998/08/17 12:27:17  carl
  1073.     * bugfix of heaperror, was pushing wrong parameter
  1074.  
  1075.   Revision 1.4  1998/07/08 11:54:40  carl
  1076.     + reinstated hepasize function
  1077.     * renamed HEAPSIZE global var to HEAP_SIZE to remove conflicts
  1078.  
  1079.   Revision 1.3  1998/07/02 14:24:08  michael
  1080.   Undid carls changes, but renamed _heapsize to _internal_heapsize. Make cycle now works
  1081.  
  1082.   Revision 1.2  1998/07/02 12:22:38  carl
  1083.     - removed heapsize function, would cause conflicts with HEAPSIZE var
  1084.     * GetHeapstart was misplaced
  1085.  
  1086.   Revision 1.1.1.1  1998/03/25 11:18:44  root
  1087.   * Restored version
  1088.  
  1089.   Revision 1.3  1998/01/26 12:01:52  michael
  1090.   + Added log at the end
  1091.  
  1092.  
  1093.   
  1094.   Working file: rtl/m68k/heap.inc
  1095.   description:
  1096.   ----------------------------
  1097.   revision 1.2
  1098.   date: 1998/01/05 16:51:24;  author: michael;  state: Exp;  lines: +31 -1
  1099.   + Moved init of heap to heap.inc: INITheap() (From Peter Vreman)
  1100.   ----------------------------
  1101.   revision 1.1
  1102.   date: 1998/01/05 00:32:44;  author: carl;  state: Exp;
  1103.   + First Version of m68k heap handler (handles amiga/macos/atari)
  1104.   =============================================================================
  1105. }
  1106.